home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / tpascal / vbxwz / samples / tooltip.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-12-13  |  4.6 KB  |  137 lines
  1. {
  2.   Program: ToolTip
  3.   Date: 15/10/1994
  4.   Purpose: To create a custom control (vbx) for Visual Basic
  5. }
  6. Library ToolTip;
  7. {$R ToolTip}
  8. Uses WinTypes,WinProcs,BPVBApi;
  9. { Custom control data and structs }
  10. Type PToolTip=^TToolTip;
  11.      TToolTip=Record
  12.      End;
  13. Const 
  14. { Declare Property }
  15. { Declare Events }
  16.       Params_Event_ToolTip:array[0..0]of word=(ET_SD);
  17.       Event_ToolTip:TEVENTINFO=(
  18.       npszName:NPnt(PChar('ToolTip'));
  19.       cParms:1;
  20.       cwParms:2;
  21.       npParmTypes:NPnt(@Params_Event_ToolTip);
  22.       npszParmProf:NPnt(PChar('CtlName as String'));
  23.       fl:0);
  24. { Property List }
  25.       PropListToolTip:array[0..20] of PPropInfo=(
  26.       PPropInfo_Std_BACKCOLOR,
  27.       PPropInfo_Std_CAPTION,
  28.       PPropInfo_Std_CTLNAME,
  29.       PPropInfo_Std_ENABLED,
  30.       PPropInfo_Std_FONTBOLD,
  31.       PPropInfo_Std_FONTITALIC,
  32.       PPropInfo_Std_FONTNAME,
  33.       PPropInfo_Std_FONTSIZE,
  34.       PPropInfo_Std_FONTSTRIKE,
  35.       PPropInfo_Std_FONTUNDER,
  36.       PPropInfo_Std_FORECOLOR,
  37.       PPropInfo_Std_HEIGHT,
  38.       PPropInfo_Std_HWND,
  39.       PPropInfo_Std_INDEX,
  40.       PPropInfo_Std_LEFT,
  41.       PPropInfo_Std_PARENT,
  42.       PPropInfo_Std_TAG,
  43.       PPropInfo_Std_TOP,
  44.       PPropInfo_Std_VISIBLE,
  45.       PPropInfo_Std_WIDTH,0);
  46. { Event List }
  47.       EventListToolTip:array[0..3] of PEventInfo=(
  48.       PEventInfo(@Event_ToolTip),
  49.       PEventInfo_Std_CLICK,
  50.       PEventInfo_Std_MOUSEMOVE,0);
  51. { Constans and Variables }
  52. var lpfnWndProc,lpfnOldWndProc,NewProc:TFarProc;
  53.     CtlName:hLstr;
  54.     ActiveCtl,ToolTipWnd:hWnd;
  55.     Buff:array [0..255] of Char;
  56.     ToolTipCtl:hCtl;
  57. function MainWndProc(Wnd:HWnd;Msg,WParam:Word;LParam:Longint):Longint; export;
  58. var I:Integer;
  59. begin
  60.   case Msg of
  61.    WM_SetCursor:
  62.    if (VBGetMode=Mode_Run)and(ActiveCtl<>wParam) then
  63.    begin
  64.      SetWindowPos(ToolTipWnd,0,640,480,0,0,Swp_NoSize);
  65.      ActiveCtl:=wParam;
  66.      I:=GetWindowText(wParam,Buff,GetWindowTextLength(wParam)+1);
  67.      CtlName:=VBCreateHlstr(@Buff,I);
  68.      VBFireEvent(ToolTipCtl,0,@CtlName);
  69.      VBDestroyHlstr(CtlName);
  70.    end;
  71.   end;
  72.   MainWndProc:=CallWindowProc(lpfnOldWndProc,Wnd,Msg,wParam,lParam);
  73. end;
  74. { Control Procedure }
  75. { This routine is called for all VB and Windows Messages }
  76. function ToolTipCtlProc(Control:hCtl;Wnd:hWnd;Msg,wParam:Word;lParam:LongInt):LongInt; Export;
  77. var RectWnd,RectCtl:TRect;
  78.     GTE:LongInt;
  79.     TP:TPaintStruct;
  80. begin
  81.   case Msg of
  82.     WM_CREATE:
  83.     begin
  84.       ToolTipCtl:=Control;
  85.       ToolTipWnd:=Wnd;
  86.       NewProc:=MakeProcInstance(@MainWndProc,VBGetHInstance);
  87.       lpfnOldWndProc:=TFarProc(GetWindowLong(GetParent(Wnd),GWL_WNDPROC));
  88.       SetWindowLong(GetParent(Wnd),GWL_WNDPROC,LongInt(NewProc));
  89.     end;
  90.     WM_DESTROY:FreeProcInstance(NewProc);
  91.     $C000:
  92.     begin
  93.       Buff[0]:=#0;
  94.       GetWindowRect(ActiveCtl,RectCtl);
  95.       GetWindowRect(GetParent(Wnd),RectWnd);
  96.       GetWindowText(ToolTipWnd,Buff,GetWindowTextLength(ToolTipWnd)+1);
  97.       BeginPaint(Wnd,TP);
  98.       GTE:=GetTextExtent(TP.hDC,Buff,lStrLen(Buff));
  99.       EndPaint(Wnd,TP);
  100.       MoveWindow(Wnd,RectCtl.Left-RectWnd.Left-GetSystemMetrics(SM_CXBorder),
  101.       RectCtl.Bottom-RectWnd.Top-GetSystemMetrics(SM_CYCaption),
  102.       LoWord(GTE)+5,HiWord(GTE),True);
  103.     end;
  104.     VBM_SETPROPERTY:if wParam=1 then PostMessage(Wnd,$C000,0,0);
  105.   end;    { End of case Msg }
  106.   ToolTipCtlProc:=VBDefControlProc(Control,Wnd,Msg,wParam,lParam);
  107. end; {End of Control function}
  108. { Model struct                               }
  109. { Define the control model                   }
  110. { (using the event and property structures). }
  111. Const ModelToolTip:TModel=(
  112.       UsVersion:VB_Version;       { VB version used by control }
  113.       Fl:0 or MODEL_fFocusOk or MODEL_fMnemonic;
  114.       CtlProc:TFarProc(@ToolTipCtlProc);
  115.       FsClassStyle:0 or cs_HRedraw or cs_VRedraw;
  116.       FlWndStyle:0 or ss_Center or ws_Border;
  117.       CbCtlExtra:SizeOf(TToolTip);
  118.       IdBmpPalette:8000;          { Bitmap ID for tool palette }
  119.       DefCtlName:NPnt(PChar('ToolTip'));
  120.       ClassName:NPnt(PChar('ToolTip'));
  121.       ParentClassName:NPnt(PChar('Static'));
  122.       PropList:Ofs(PropListToolTip);
  123.       EventList:Ofs(EventListToolTip);
  124.       NDefProp:0;                 { Index of default property }
  125.       NDefEvent:0);               { Index of default event }
  126. { Register custom control.                     }
  127. { This routine is called by VB when the custom }
  128. { control DLL is loaded for use.               }
  129. function VBInitCC(usVersion:Word;fRunTime:Boolean):Boolean; Export;
  130. begin
  131.   VBInitCC:=VBRegisterModel(hInstance,ModelToolTip);
  132. end;
  133. Exports
  134.   VBInitCC       index 2,
  135.   ToolTipCtlProc index 3;
  136. Begin
  137. End. { End of Custom Control }